PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/gsdbloo.exe/GS_DBL.PAS

Pascal/Delphi Source File | 1992-02-28 | 11.3 KB | 360 lines

{------------------------------------------------------------------------------
                           Floating Point Formatting

       GS_DBL Copyright (c)  Richard F. Griffin

       16 February 1992

       102 Molded Stone Pl
       Warner Robins, GA  31088

       -------------------------------------------------------------
       This unit handles the routines to create and compare floating
       point type doubles used in dBase indexes.  These routines save
       10K of memory over the $N,E option for numeric coprocessor emulation.

       This unit will also convert from double to string.  This is done
       by first converting from double to real and then using the Str
       procedure.  Because of this, there may be inaccuracies for numbers
       greater than 10-11 digits.

       dBase III indexes use type double to store all numeric and date
       field keys.

       changes:

------------------------------------------------------------------------------}

unit GS_Dbl;
interface
{$D-}

type

{-----------------------------------------------------------------------------
   gsDouble type simulates IEEE double precision type.
   Memory layout is:

                                 gsDouble Bytes
        ┌────────┬────────┬────────┬───┴────┬────────┬────────┬───────────┐
       [7]      [6]      [5]      [4]      [3]      [2]      [1]      [0]
    76543210 76543210 76543210 76543210 76543210 76543210 76543210 76543210
    seeeeeee│eeeemmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm
    │└┴┴┴┴┴┴─┴┴┴┘└┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┘
    │  Exponent                        Mantissa
    └─ Sign

    Note the value is stored opposite from its representation; that is, the
    sign/(MSB exponent) byte is stored in gsDouble[7].  The next byte, with
    the (LSB exponent)/ (MSB Mantissa) is gsDouble[6]; and so on.....

-----------------------------------------------------------------------------}

   gsDouble    = array[0..7] of byte;


function CmprDouble(var v1, v2) : integer;
procedure MakeDouble(C_String: string;var dtype: gsDouble;var rcode : integer);
function CnvrtDouble(var dtype) : string;

implementation

const
   MaxNibble     = 64;
   MaxBcdNibble  = 20;
   EndNibble     = 63;

var
   Index         : integer;
   DecPlaces     : integer;
   TotPlaces     : integer;
   RndgFlag      : boolean;
   InDecimals    : boolean;
   InExponent    : boolean;
   PositiveNum   : boolean;
   PositiveExp   : boolean;

   Mantissa      : array[0..MaxNibble] of byte;
   Exponent      : array[1..3] of byte;
   DecExponent   : integer;

   BinExponent   : longint;
   GrtrZero      : boolean;
   DumpBit       : byte;

   rmdr,
   LSp,
   i             : integer;

   DblAry        : array[1..16] of byte;
   DblWrk        : gsDouble;

function CmprDouble(var v1, v2) : integer;
var
   val1     : gsDouble absolute v1;
   val2     : gsDouble absolute v2;
   val1neg,
   val2neg  : boolean;
   flg      : boolean;
   rslt     : integer;
   loop     : integer;
begin
   val1neg := val1[7] > 127;
   val2neg := val2[7] > 127;
   flg := val1neg = val2neg;
   if not flg then
   begin
      if val1neg then CmprDouble := -1 else CmprDouble := 1;
      exit;
   end;
   loop := 7;
   rslt := 0;
   while (rslt = 0) and (loop >= 0) do
   begin
      if val1[loop] < val2[loop] then rslt := -1
         else if val1[loop] > val2[loop] then rslt := 1;
      loop:= loop-1;
   end;
   if val1neg then rslt := rslt*(-1);
   CmprDouble := rslt;
end;

procedure MakeDouble(C_String: string;var dtype: gsDouble;var rcode : integer);

   procedure AdjustMantissa;
   begin
      if DecExponent < 0 then
      begin
         while DecExponent < 0 do
         begin
            while Mantissa[1] = 0 do
            begin
               move(Mantissa[2], Mantissa[1], EndNibble);
               dec(BinExponent,4);
            end;
            for i := 1 to pred(EndNibble) do
            begin
               Mantissa[succ(i)] := Mantissa[succ(i)] +
                                    ((Mantissa[i] mod 10) * 16);
               Mantissa[i] := Mantissa[i] div 10;
            end;
            Mantissa[EndNibble] := Mantissa[EndNibble] div 10;
            inc(DecExponent);
         end;
      end
      else
                         {test for exponent > 0}
         if DecExponent > 0 then
         begin
            while DecExponent > 0 do
            begin
               if Mantissa[1] <> 0 then
               begin
                  rmdr := Mantissa[EndNibble];
                  move(Mantissa[1], Mantissa[2], pred(EndNibble));
                  Mantissa[1] := 0;
                  inc(BinExponent,4);
                  if rmdr > 7 then
                  begin
                     inc(Mantissa[EndNibble]);
                     i := EndNibble;
                     while Mantissa[i] > 15 do
                     begin
                        Mantissa[i] := Mantissa[i] and $0F;
                        dec(i);
                        inc(Mantissa[i]);
                     end;
                  end;
               end;
               Mantissa[EndNibble] :=  (Mantissa[EndNibble] * 10);
               for i := pred(EndNibble) downto 1 do
               begin
                  Mantissa[i] := (Mantissa[i] * 10) +
                                 (Mantissa[succ(i)] shr 4);
                  Mantissa[succ(i)] :=
                                  Mantissa[succ(i)] and $0F;
               end;
               dec(DecExponent);
            end;
         end;
   end;



begin
   rcode := 0;
   PositiveNum := true;
   PositiveExp := true;
   DecPlaces := 0;
   DecExponent := 0;
   RndgFlag  := true;
   InDecimals := false;
   InExponent := false;
   FillChar(Mantissa,MaxNibble+1,#0);
   FillChar(Exponent,3,#0);
   if C_String <> '' then
   begin
      LSp := 1;
      while (C_String[LSp] = ' ') and (LSp <= ord(C_String[0])) do
         LSp := LSp+1;
      for Index := LSp to length(C_String) do
      begin
         case C_String[Index] of

         '+'      : if InExponent then PositiveExp := true
                       else PositiveNum := true;

         '-'      : if InExponent then PositiveExp := false
                       else PositiveNum := false;

         '0'..'9' : begin
                       if InDecimals then inc(DecPlaces);
                       if InExponent then
                       begin
                          DecExponent := (DecExponent * 10) +
                                         byte(C_String[Index]) and $0F;
                       end
                       else
                       begin
                          if Mantissa[1] = 0 then
                          begin
                             Mantissa[EndNibble] :=
                                             (Mantissa[EndNibble] * 10) +
                                             (byte(C_String[Index]) and $0F);
                             for i := pred(EndNibble) downto 1 do
                             begin
                                Mantissa[i] := (Mantissa[i] * 10) +
                                               (Mantissa[succ(i)] shr 4);
                                Mantissa[succ(i)] :=
                                                Mantissa[succ(i)] and $0F;
                             end;
                          end
                          else
                          begin
                             if RndgFlag then
                             begin
                                RndgFlag := false;
                                if C_String[Index] > '4' then
                                                     inc(Mantissa[EndNibble]);
                             end;
                             if not InDecimals then dec(DecPlaces);
                          end;
                       end;
                    end;


         '.'      : InDecimals := true;

         'e',
         'E'      : begin
                       InExponent := true;
                       InDecimals := false;
                    end;

         else       begin
                       rcode := Index;
                    end;
         end;
      end;

      if not PositiveExp then DecExponent := DecExponent * -1;
      DecExponent := DecExponent - DecPlaces;

      GrtrZero := false;
      for i := 1 to EndNibble do if Mantissa[i] > 0 then GrtrZero := true;

      if GrtrZero then
      begin

         BinExponent := EndNibble*4;
         AdjustMantissa;
         while Mantissa[1] = 0 do
         begin
            move(Mantissa[2], Mantissa[1], EndNibble);
            dec(BinExponent,4);
         end;


         DumpBit := 0;
         while DumpBit = 0 do
         begin
            dec(BinExponent);
            for i := 1 to EndNibble do Mantissa[i] := Mantissa[i] shl 1;
            DumpBit := Mantissa[1] and $10;
            for i := 1 to EndNibble do
            begin
               if Mantissa[succ(i)] > 15 then inc(Mantissa[i]);
               Mantissa[i] := Mantissa[i] and $0F;
            end;
         end;

         if Mantissa[14] > 7 then
         begin
            inc(Mantissa[13]);
            i := 13;
            while (Mantissa[i] > 15) and (i > 0) do
            begin
               Mantissa[i] := Mantissa[i] and $0F;
               dec(i);
               inc(Mantissa[i]);
            end;
         end;

         BinExponent := BinExponent + 1023;
         for i := 3 downto 1 do
         begin
            Exponent[i] := BinExponent and $000F;
            BinExponent := BinExponent shr 4;
         end;

      end;
      if not PositiveNum then Exponent[1] := Exponent[1] or $08;
   end;

   DblWrk[7] := (Exponent[1] shl 4) + Exponent[2];
   DblWrk[6] := (Exponent[3] shl 4) + Mantissa[1];
   DblWrk[5] := (Mantissa[2] shl 4) + Mantissa[3];
   DblWrk[4] := (Mantissa[4] shl 4) + Mantissa[5];
   DblWrk[3] := (Mantissa[6] shl 4) + Mantissa[7];
   DblWrk[2] := (Mantissa[8] shl 4) + Mantissa[9];
   DblWrk[1] := (Mantissa[10] shl 4) + Mantissa[11];
   DblWrk[0] := (Mantissa[12] shl 4) + Mantissa[13];
   dtype := DblWrk;
end;


function CnvrtDouble(var dtype) : string;
var
   dbl_in : gsDouble absolute dtype;
   rnum   : real;
   rpsudo : array[0..5] of byte absolute rnum;
   st     : string;
begin
   PositiveNum := dbl_in[7] < $80;
   Exponent[1] := (dbl_in[7] shr 4) and $07;
   Exponent[2] := dbl_in[7] and $0F;
   Exponent[3] := (dbl_in[6] shr 4) and $0F;
   BinExponent := 0;
   for i := 1 to 3 do
      BinExponent := (BinExponent shl 4) or Exponent[i];
   BinExponent := BinExponent - 1023;
   rpsudo[0] := BinExponent + 129;
   rpsudo[5] := (dbl_in[6] shl 3) and $78;
   rpsudo[5] := (dbl_in[5] shr 5) or rpsudo[5];
   if not PositiveNum then rpsudo[5] := rpsudo[5] or $80;
   rpsudo[4] := (dbl_in[5] shl 3);
   rpsudo[4] := (dbl_in[4] shr 5) or rpsudo[4];
   rpsudo[3] := (dbl_in[4] shl 3);
   rpsudo[3] := (dbl_in[3] shr 5) or rpsudo[3];
   rpsudo[2] := (dbl_in[3] shl 3);
   rpsudo[2] := (dbl_in[2] shr 5) or rpsudo[2];
   rpsudo[1] := (dbl_in[2] shl 3);
   rpsudo[1] := (dbl_in[1] shr 5) or rpsudo[1];
   str(rnum,st);
   CnvrtDouble := st;
end;

end.
{-----------------------------------------------------------------------------}
                                      END